#!/usr/bin/perl

# $Id$

=head1 NAME

Swignition::DataModel::Node - Base class for a few others.

=cut

package Swignition::DataModel::Node;

use Carp;
use URI::URL;

use constant TRUE      =>  1;
use constant FALSE     =>  0;
use strict;

our $_internal_id = 1;

=head1 CONSTRUCTORS

=over

=item $node = Swignition::DataModel::Node->new($model)

Create a new node. Generally you do not want to do this - you want to
instantiate a subclass instead.

A noteworthy feature of Swignition::DataModel::Node's internal storage is
that although it is a hashref, all a node's data is actually stored in
another hashref referenced by C<$node->{'_'}>. This is because nodes
occasionally need to be merged, and using this indirect method of storage
makes that a lot easier. People using Swignition::DataModel::Node do not
need to worry about all that, but people writing extensions should be very
aware of it.

=cut

sub new
{
	my $class = shift;
	my $model = shift;
	
	my $this = {
		'_' => {
			'usage' => {
				'subject_of'     => [],   # list of triples
				'predicate_of'   => [],   # list of triples
				'object_of'      => [],   # list of triples
				'node_in'        => [],   # list of graphs
				'triple_of'      => [],   # list of graphs
				'defined_in'     => $model,
			},
			'identity' => {
				'uri'            => [],
				'internal'       => $Swignition::DataModel::Node::_internal_id++,
				'claimed_name'   => undef,
			},
			'in_model' => 0,
			'associated_objects' => {},
		},
	};
	
	bless $this, $class;
	return $this;
}

=back

=head1 PUBLIC METHODS

=over

=item $node->subject_of

A list of triples where this node is the subject.

=cut

sub subject_of
{
	my $this = shift;
	return $this->{'_'}->{'usage'}->{'subject_of'};
}

=item $node->predicate_of

A list of triples where this node is the predicate.

=cut

sub predicate_of
{
	my $this = shift;
	return $this->{'_'}->{'usage'}->{'predicate_of'};
}

=item $node->object_of

A list of triples where this node is the object.

=cut

sub object_of
{
	my $this = shift;
	return $this->{'_'}->{'usage'}->{'object_of'};
}

=item $node->model

Returns the model where this node is defined.

=cut

sub model
{
	my $this = shift;
	return $this->{'_'}->{'usage'}->{'defined_in'};
}

=item $node->node_in

A list of graphs where this node is used as a subject, predicate or object.

=cut

sub node_in
{
	my $this = shift;
	return $this->{'_'}->{'usage'}->{'node_in'};
}

=item $node->in_graph($g)

Returns true iff $node is a node in graph $g.

=cut

sub in_graph
{
	my $this = shift;
	my $g    = shift;
	
	foreach my $graph ($this->node_in)
	{
		return TRUE
			if ($graph->same_as($g));
	}
	
	return FALSE;
}

=item $node->add_usage($usage, $place).

Notifies $node that it is being used as $usage by $place.

=cut

sub add_usage
{
	my $this  = shift;
	my $usage = shift;
	my $user  = shift;
	
	confess "Graphs and Triples are disjoint!"
		if ($usage eq 'triple_of' && $this->isa('Swignition::DataModel::Graph'));

	confess "Only a Graph can have triples!"
		if ($usage eq 'has_triple' && !$this->isa('Swignition::DataModel::Graph'));

	my $already_known = 0;
	foreach my $u (@{ $this->{'_'}->{'usage'}->{$usage} })
	{
		$already_known = 1 if ($user->same_as($u));
	}

	unless ($already_known)
	{
		push @{ $this->{'_'}->{'usage'}->{$usage} }, $user;
	}
	
	return $this;
}

=item $node->add_associated_object($object, $object_type)

Stores an object of some kind that is associated with this node. e.g. could
be a hashref representation of a microformat.

=cut

sub add_associated_object
{
	my $this   = shift;
	my $object = shift;
	my $type   = shift || (ref $object);

	foreach my $o (@{ $this->{'_'}->{'associated_objects'}->{$type} })
	{
		return $this if $o==$object;
	}

	push @{ $this->{'_'}->{'associated_objects'}->{$type} }, $object;

	return $this;
}

=item $node->same_as($an_other)

Returns true iff $node is the same as $an_other.

=cut

sub same_as
{
	my $this = shift;
	my $node = shift;
	
	return ($this->internal_id == $node->internal_id);
}


=item $node->answers_to($uri)

Returns true iff $node has a URI.

=cut

sub answers_to
{
	my $this  = shift;
	my $str   = shift;
	
	if ($str =~ m/^_:(.+)$/)
	{
		return ((defined $this->{'_'}->{'identity'}->{'claimed_name'})
			&&   (substr($str, 2) eq $this->{'_'}->{'identity'}->{'claimed_name'}));
	}
	else
	{
		foreach my $uri ($this->uris)
		{
			return TRUE if "$uri" eq $str; 
		}
	}
}


=item $node->internal_id

Returns an internal identifier number for this resource.

=cut

sub internal_id
{
	my $this = shift;
	return $this->{'_'}->{'identity'}->{'internal'};
}

=item $node->add_uri($uri, $priority)

Add a new URI for the resource. Can optionally specify a priority used by
C<$node->uri>.

=cut

sub add_uri
{
	my $this = shift;
	my $uri  = shift;
	my $p    = shift || 0;
	my $nolookup = shift || FALSE;
	
	unless ($nolookup)
	{
		my $existing = $this->model->lookup_node("$uri", FALSE);
	
		if ($existing)
		{
			$this->merge_with($existing);
			return $this;
		}
	}
	
	my $already = FALSE;
	foreach my $u ($this->uris)
		{ $already = TRUE if ("$u" eq "$uri"); }
	push @{$this->{'_'}->{'identity'}->{'uri'}}, 
		{ 'string'=>"$uri" , 'score'=>$p }
		unless ($already);
	
	return $this;
}

=item $node->uris

Returns array of all known URIs describing this resource.

=cut

sub uris
{
	my $this = shift;
	my @rv;
	
	foreach my $U (@{$this->{'_'}->{'identity'}->{'uri'}})
	{
		push @rv, url $U->{'string'};
	}
	
	return @rv;
}

=item $node->uri

Returns the best URI describing this resource.

=cut

sub uri
{
	my $this = shift;
	my $rv;
	my $bestscore = 0;
	
	foreach my $U (@{$this->{'_'}->{'identity'}->{'uri'}})
	{
		$rv = url $U->{'string'}
			if ($U->{'score'} > $bestscore || !$rv);
	}
	
	return $rv;
}

=item $node->identity

Returns the best way of identifying $node. This will be a URI::URL object or a
string taking the form "_:foo".

=cut

sub identity
{
	my $this  = shift;
	
	my $uri = $this->uri;
	return $uri if defined $uri;
	
	return '_:' . $this->{'_'}->{'identity'}->{'claimed_name'} 
		if defined $this->{'_'}->{'identity'}->{'claimed_name'};
	
	return sprintf('_:n%04d', $this->internal_id);
}

=item $node->claim_name($name)

Tries to claim a particular name for the node. If the name is already used in
the model, uses a different name instead.

=cut

sub claim_name
{
	my $this = shift;
	my $name = shift;
	
	$this->{'_'}->{'identity'}->{'claimed_name'} = $this->model->register_node_name($this, $name)
		unless defined $this->{'_'}->{'identity'}->{'claimed_name'};
	return $this->{'_'}->{'identity'}->{'claimed_name'};
}

=item $node->is_literal

Returns TRUE iff this node represents a literal.

=cut

sub is_literal
{
	my $this  = shift;
	return $this->isa('Swignition::DataModel::Literal');
}

=item $node->mergeable($an_other)

Returns true if (theoretically) this node can be merged with another node.

=cut

sub mergeable
{
	my $this = shift;
	my $that = shift;
	
	return ((ref $this) eq (ref $that));
}

=item $node->merge_with($an_other)

Merges a node with another node.

=cut

sub merge_with
{
	my $this = shift;
	my $that = shift;
	
	croak "Cannot merge these.\n" unless ($this->mergeable($that));
	
	# Merge references
	foreach my $triple (@{$that->subject_of})
		{ $this->add_usage('subject_of', $triple); }
	foreach my $triple (@{$that->predicate_of})
		{ $this->add_usage('predicate_of', $triple); }
	foreach my $triple (@{$that->object_of})
		{ $this->add_usage('object_of', $triple); }
	foreach my $triple (@{$that->node_in})
		{ $this->add_usage('node_in', $triple); }
	
	if ($that->can('triple_of'))
	{
		foreach my $triple (@{$that->triple_of})
			{ $this->add_usage('object_of', $triple); }
	}

	if ($that->can('get_triples'))
	{
		foreach my $triple (@{$that->get_triples})
			{ $this->add_usage('has_triple', $triple); }
	}

	if ($that->can('get_nodes'))
	{
		foreach my $triple (@{$that->get_nodes})
			{ $this->add_usage('has_node', $triple); }
	}
	
	# Merge identifiers.
	foreach my $u ($that->uris)
		{ $this->add_uri($u, 0, TRUE); }
	$this->{'_'}->{'identity'}->{'claimed_name'} = 
		$that->{'_'}->{'identity'}->{'claimed_name'}
		if (length $that->{'_'}->{'identity'}->{'claimed_name'}
		&& !defined $this->{'_'}->{'identity'}->{'claimed_name'});
	
	# Merge associated objects.
	foreach my $type (keys %{$that->{'_'}->{'associated_objects'}})
	{
		foreach my $object (@{$that->{'_'}->{'associated_objects'}->{$type}})
		{
			$this->add_associated_object($object, $type);
		}
	}
		
	# Tear out $that's guts and replace with a reference to $this's.
	$that->{'_'} = $this->{'_'};
	$this->{'_'}->{'in_model'} = 0;

	return $this;
}

=item $subject->query($predicate, [$graph1, $graph2, ...])

Finds the triples with subject $subject and predicate $predicate.

=cut

sub query
{
	my $this      = shift;
	my $predicate = shift;
	my $graphs    = shift;
	my @rv;
	
	if ((ref $predicate) && $predicate->isa('Swignition::DataModel::Node'))
		{ $predicate = $predicate->identity; }
	else
		{ $predicate = "$predicate"; }
	
	OUTLOOP: foreach my $triple (@{$this->subject_of})
	{
		if ((defined $graphs) && @$graphs)
		{
			my $in_a_relevant_graph = FALSE;
			MIDLOOP: foreach my $relevant_graph (@$graphs)
			{
				INLOOP: foreach my $graph (@{$triple->triple_of})
				{
					if ($graph->same_as($relevant_graph))
					{
						$in_a_relevant_graph = TRUE;
						last MIDLOOP;
					}
				} #INLOOP
			} #MIDLOOP
			
			next unless $in_a_relevant_graph;	
		}
	
		push @rv, $triple
			if ($triple->predicate->answers_to($predicate));
			
	} #OUTLOOP

	return @rv;
}

=item $subject->query_resource($predicate, [$graph1, $graph2, ...])

Like query(), but does not return triples with literal objects.

=cut

sub query_resource
{
	my @rv;
	foreach my $t (query(@_))
	{
		push @rv, $t
			unless $t->object->is_literal;
	}
	return @rv;
}

=item $subject->query_literal($predicate, [$graph1, $graph2, ...])

Like query(), but only returns triples with literal objects.

=cut

sub query_literal
{
	my @rv;
	foreach my $t (query(@_))
	{
		push @rv, $t
			if $t->object->is_literal;
	}
	return @rv;
}

=item $subject->a($rdf_class, [$graph1, $graph2, ...])

Returns true if there exists in one of the graphs a triple ($subject, rdf:type,
$object) where $object answers to the URI $rdf_class.

=cut

sub a
{
	my $this   = shift;
	my $class  = shift;
	my $graphs = shift;

	# Everything's an rdfs:Resource.
	if ($class eq 'http://www.w3.org/2000/01/rdf-schema#Resource')
	{
		return TRUE;
	}

	# rdf:XMLLiteral is not just a datatype - it can be used as a class
	if ($class eq 'http://www.w3.org/1999/02/22-rdf-syntax-ns#XMLLiteral')
	{
		return TRUE if $this->isa('Swignition::DataModel::XMLLiteral');
		return TRUE if $this->is_literal && ($this->datatype eq $class);
	}

	# Literals
	if ($this->is_literal)
	{
		return TRUE
			if ($class eq 'http://www.w3.org/2000/01/rdf-schema#Literal');
		return TRUE if $this->datatype eq $class;
	}

	if ((ref $class) && $class->isa('Swignition::DataModel::Node'))
		{ $class = $class->identity; }
	else
		{ $class = "$class"; }

	my @types = $this->query_resource('http://www.w3.org/1999/02/22-rdf-syntax-ns#type', $graphs);
	foreach my $type (@types)
		{ return TRUE if $type->object->answers_to($class); }
	
	return FALSE;
}

=back

=cut

1;
